#!/usr/bin/perl -w

use strict;
use warnings;
use Carp;
use File::Spec::Functions qw(catfile);
use Getopt::Std;
use Pod::Find qw(pod_find pod_where);
use Pod::Usage;

$SIG{__WARN__} = \&Carp::confess;

sub HELP_MESSAGE {
    my ($fh) = @_;
    pod2usage(-output => $fh);
}

sub narrate {
    # For verbose mode messages
    print STDERR @_
	if $::opt_v;
}

our ($opt_a, $opt_l, $opt_p, $opt_s, $opt_w, $opt_v);
$Getopt::Std::STANDARD_HELP_VERSION = 1;
getopts('al:p:s:w:v');
pod2usage(2)
    if not @ARGV;
die "Directory '$opt_w' doesn't exist\n"
    if $opt_w and not -d $opt_w;
my %options;
$options{page_labels}  = $opt_l
    if $opt_l;
$options{page_prefix}  = $opt_p
    if $opt_p;
$options{page_summary} = $opt_s
    if $opt_s;
my $parser = Pod::GoogleCodeWiki->new(%options);

# Generate hash of type { filename => podname }
narrate("Searching for POD files...\n");
my %podmap;
if ($opt_a) {
    %podmap = pod_find({-perl => 1}, @ARGV)
}
else {
    for (@ARGV) {
	my $file = pod_where({}, $_);
	if ($file) {
	    $podmap{$file} = $_;
	}
	else {
	    warn "Unable to locate any POD for '$_'\n";
	}
    }
}
narrate("...done. Total found: ", scalar(keys %podmap), "\n");

# Convert podnames to wiki file names if using -w, undef otherwise
for (values %podmap) {
    $_ = $opt_w ? catfile($opt_w, $parser->wikify_podlink($_).'.wiki') : undef;
}

# Perform conversions
narrate("Performing conversions...\n");
binmode(STDOUT, ':utf8');
while (my ($inputfilename, $outputfilename) = each %podmap) {
    use open IN => ':locale', OUT => ':utf8';
    my ($inputfile, $outputfile);
    narrate("+ Now converting:\n  source: $inputfilename\n",
	    ($outputfilename ? "  target: $outputfilename\n" : ''));
    open($inputfile, '<', $inputfilename)
	or die "unable to open '$inputfilename' for reading: $!\n";
    open($outputfile, '>', $outputfilename)
	or die "unable to open '$outputfilename' for writing: $!\n"
	    if $outputfilename;
    $parser->parse_from_file($inputfile, $outputfile);
    close($inputfile);
    close($outputfile)
	if $outputfile;
}
narrate("...done.\n");

exit (0);


package Pod::GoogleCodeWiki;
use strict;
use warnings;
use base qw(Pod::Parser);
use IO::Handle;
use Pod::ParseLink;

# use Pod::Escapes if available.
BEGIN {
    eval {
	require Pod::Escapes;
	import Pod::Escapes qw(e2char);
	our $ESCAPES = 1;
    }
}

use constant ENT => {lt => '<',
		     gt => '>',
		     sol => '/',
		     verbar => '|',
		    };
use constant WIKIWORD_RE => qr'\b(?:[A-Z][a-z0-9_]+){2,}\b';
#use constant PAGENAME_RE => qr'\b(?!_)\w+';


sub initialize {
    my ($self) = @_;
    $self->{command_handler} = {
	'over'  => \&command_over,
	'back'  => \&command_back,
	'item'  => \&command_item,
	'head1' => sub { push @_, 1; &command_head },
	'head2' => sub { push @_, 2; &command_head },
	'head3' => sub { push @_, 3; &command_head },
	'head4' => sub { push @_, 4; &command_head },
	'pod'   => sub { },
	'begin' => sub { },
	'end'   => sub { },
    };
    $self->{to_wiki} = {
	''  => \&escape_pod,
	'I' => sub { push @_, '___'; &render_simple_inline },
	'B' => sub { push @_, '_*_'; &render_simple_inline },
	'C' => \&render_code,
	'L' => \&render_wiki_link,
	'E' => sub { $_[0]->escape_pod(&render_e_code) },
	'F' => \&render_code,
	'S' => \&render_tree,
	'X' => sub { '' },
	'Z' => sub { '' },
    };
    $self->{to_code} = {
	''  => \&encode_pod,
	'I' => sub { push @_, '_'; &render_simple_inline },
	'B' => sub { push @_, '_*_'; &render_simple_inline },
	'C' => \&render_tree,
	'L' => \&render_plain_link,
	'E' => sub { $_[0]->encode_pod(&render_e_code) },
	'F' => \&render_tree,
	'S' => \&render_tree,
	'X' => sub { '' },
	'Z' => sub { '' },
    };
    $self->{to_plain} = {
	''  => sub { $_[1] },
	'I' => \&render_tree,
	'B' => \&render_tree,
	'C' => \&render_tree,
	'L' => \&render_plain_link,
	'E' => sub { e2char($_[1]) },
	'F' => \&render_tree,
	'S' => \&render_tree,
	'X' => sub { '' },
	'Z' => sub { '' },
    };
    $self->{page_prefix} = 'Pod'
	if not exists($self->{page_prefix});
    $self->{page_summary} = 'Converted POD documentation.'
	if not exists($self->{page_summary});
    $self->{page_labels} = 'ManPage'
	if not exists($self->{page_labels});
    $self->SUPER::initialize;
}

sub begin_pod {
    my ($self) = @_;
    $self->{mode} = 'to_wiki';
    $self->{indent} = 0;
    $self->prefix('');
    $self->suffix("\n");
    $self->output("#summary ".$self->{page_summary}."\n")
	if $self->{page_summary};
    $self->output("#labels ".$self->{page_labels}."\n")
	if $self->{page_labels};
    $self->output("_This page was generated from POD using [http://code.google.com/p/pod2gcw pod2gcw] and is not intended for editing._\n");
    $self->output("\n");
}

sub command {
    my ($self, $cmd, $text, $line_num, $para) = @_;
    # Canonify command as lower case.
    $cmd = lc($cmd);
    # Strip trailing space and newlines.
    $text =~ s/\s*\n*$//s;
    if (exists($self->{command_handler}->{$cmd})) {
	&{$self->{command_handler}->{$cmd}}($self, $text, $line_num);
    }
    else {
	$self->warning("Unrecognised command paragraph '$cmd' at ".$para->file_line."\n");
    }
}

sub command_over {
    my ($self, $text, $line_num) = @_;
    $self->indent(+1);
    $self->prefix('');
    $self->suffix('');
}

sub command_back {
    my ($self, $text, $line_num) = @_;
    $self->prefix('');
    if (!$self->indent) {
	$self->warning("Encountered 'back' while not indented at line $line_num\n");
	$self->warning("  Remaining at indent level zero.\n");
	$self->suffix("\n");
    }
    elsif ($self->indent(-1)) {
	$self->suffix('');
    }
    else {
	$self->suffix("\n");
    }
}

sub command_item {
    my ($self, $text, $line_num) = @_;
    if (!$self->indent) {
	$self->warning("Encountered 'item' outside 'over' block at line $line_num\n");
	$self->warning("  Executing implicit 'over' command.\n");
	$self->command_over($text, $line_num);
    }
    if ($text eq '' or $text eq '*') {
	# Bullet list item
	$self->prefix('* ');
    }
    elsif ($text =~ /^\d+\.?/) {
	# Numeric list item
	$self->prefix('# ');
    }
    else {
	# Text list item (starts at parent indent level)
	$self->indent(-1);
	$self->prefix('');
	$self->text_item_suffix;
	$self->textblock($text, $line_num);
	$self->indent(+1);
	$self->prefix('');
	$self->text_item_suffix;
    }
}

sub command_head {
    my ($self, $text, $line_num, $level) = @_;
    # Headings are not supposed to occur in over/back blocks.
    while ($self->indent) {
	$self->warning("Encountered heading inside 'over' block at line $line_num\n");
	$self->warning("  Executing implicit 'back' command.\n");
	$self->command_back($text, $line_num);
    }
    $self->prefix('=' x ($level + 1));
    $self->suffix('=' x ($level + 1));
    $self->textblock($text, $line_num);
    $self->prefix('');
    $self->suffix("\n");
}

sub verbatim {
    my ($self, $paragraph, $line_num) = @_;
    # We expect these paragraphs to have at least two terminating newlines.
    chomp $paragraph;
    $self->output("{{{\n$paragraph}}}\n");
}

sub textblock {
    my ($self, $paragraph, $line_num) = @_;
    # Strip trailing spaces and newlines.
    $paragraph =~ s/\s*\n*$//s;
    # Convert embedded newlines to spaces.
    $paragraph =~ s/\n/ /g;
    $self->output($self->indent_text, $self->prefix);
    $self->output($self->render_tree($self->parse_text($paragraph, $line_num)));
    $self->output($self->suffix, "\n");
}

sub render_tree {
    my ($self, $tree) = @_;
    # Returns the parse tree $tree as wiki markup
    my $result = '';
    for ($tree->children) {
	$result .= $self->render_node($_);
    }
    return ($result);
}

sub render_node {
    my ($self, $node) = @_;
    # Converts either InteriorSequence or plain text to wiki markup.
    my $handler = $self->{$self->{mode}};
    if (ref($node)) {
	# $node is an InteriorSequence
	my $cmd = uc($node->cmd_name);
	if (exists($handler->{$cmd})) {
	    return (&{$handler->{$cmd}}($self, $node->parse_tree));
	}
	else {
	    $self->warning("No '".$self->{mode}."' handler for '$cmd' sequence at ".$node->file_line."\n");
	    $self->warning("+ Returning null text for that construct!\n");
	    return ('');
	}
    }
    else {
	# $node is plain text, handled by the null pseudo-command.
	return (&{$handler->{''}}($self, $node));
    }
}

sub render_simple_inline {
    my ($self, $tree, $markup) = @_;
    my $result = $markup;
    $result .= $self->render_tree($tree);
    $result .= $markup;
    return ($result);
}

sub render_code {
    my ($self, $tree) = @_;
    # Note the following use of "local" to save/restore mode.
    local $self->{mode} = 'to_code';
    return ($self->render_tree($tree));
}

sub render_e_code {
    my ($self, $tree) = @_;
    my $code = eval {
	local $self->{mode} = 'to_plain';
	$self->render_tree($tree);
    };
    return (e2char($code))
	if our $ESCAPES;
    my $char;
    if ($code =~ /^\d/) {
	my $num = $code;
	$num = eval { oct($num) }
	    if $num =~ /^0/;
	$char = eval { chr($num) };
    }
    else {
	$char = ENT->{$code};
    }
    return ($char)
	if $char;
    $self->warning("Unrecognised E<> code '$code' not converted.\n");
    return ("E<$code>");
}

sub render_wiki_link {
    my ($self, $tree) = @_;
    my ($text, $inf, $link, $sec, $type) = eval {
	local $self->{mode} = 'to_plain';
	parselink($self->render_tree($tree));
    };
    if ($type eq 'url') {
	return ("<[$link]>");
    }
    elsif ($type eq 'pod' or $type eq 'man') {
	my $pagename = $self->wikify_podlink($link);
	# This conversion fails if $text or $inf contains a ']'. Unfixable?
	return ($text ? "[$pagename $text]" : "[$pagename $inf]");
    }
    else {
	$self->warning("Pod::ParseLink returned unexpected link type '$type'.\n");
	return ($self->escape_pod($text ? $text : $inf));
    }
}

sub render_plain_link {
    my ($self, $tree) = @_;
    my ($text, $inf) = parselink($self->render_tree($tree));
    return ($text ? $text : $inf);
}

sub indent {
    my ($self, $indent) = @_;
    # Returns the current indent level (integer). Optionally adjusts the indent level first (e.g. +1 or -1).
    $self->{indent} += $indent
	if $indent;
    Carp::confess("Bug: indent has gone below zero")
	  if $self->{indent} < 0;
    return ($self->{indent});
}

sub indent_text {
    my ($self, $offset) = @_;
    # Returns a number of spaces representing the current indent level (plus an optional offset).
    $offset ||= 0;
    Carp::confess("Bug: attempt to produce negative indent text")
	  if $self->indent + $offset < 0;
    return ('  ' x ($self->indent + $offset));
}

sub prefix {
    my ($self, $prefix) = @_;
    # Returns (after optionally setting) the current prefix
    $self->{prefix} = $prefix
	if defined($prefix);
    return ($self->{prefix});
}

sub suffix {
    my ($self, $suffix) = @_;
    # Returns (after optionally setting) the current suffix
    $self->{suffix} = $suffix
	if defined($suffix);
    return ($self->{suffix});
}

sub text_item_suffix {
    my ($self, $suffix) = @_;
    # This ugly hack sets a suffix that is always suitable for formatting text list items.
    $suffix ||= '';
    $suffix .= "\n";
    $suffix .= $self->indent_text(-1).'__'
	if $self->indent > 0;
    $suffix .= "\n".$self->indent_text.'__';
    $self->suffix($suffix);
}

sub output {
    my $self = shift;
    # Why isn't this provided as a method in Pod::Parser?
    $self->output_handle->print(@_);
}

sub warning {
    my ($self, $errmsg) = @_;
    # Why isn't this provided as a method in Pod::Parser?
    my $errorsub = $self->errorsub();
    if (ref $errorsub) {
	&{$errorsub}($errmsg);
    }
    elsif (defined $errorsub) {
	$self->$errorsub($errmsg);
    }
    else {
	local $SIG{__WARN__};
	warn($errmsg);
    }
}

sub wikify_podlink {
    my ($self, $podlink) = @_;
    # Accepts a pod or man link and converts to a legal page name
    $podlink =~ s/[^A-Za-z0-9_]+/_/g;
    return ($self->{page_prefix}.'_'.$podlink);
}

sub escape_pod {
    # Yes, the name is a joke.
    my $self = shift;
    local $_ = shift;
    # Inserts escape sequences in POD text for wiki-safeness.
    # I'm initially going to use ESC (\e) as a placeholder markup-interrupter.
    # Neutralise any code-markup open-brace constructs by interrupting them.
    s/{{(?={)/{{\e/g;
    # Separate any open braces from backticks with an interrupt.
    s/{`/{\e`/g;
    # Then wrap the backticks in triple-braces.
    s/`+/{{{$1}}}/g;
    # The following set of characters are markup-significant. We wrap them in backticks.
    s/([*_^]+)/`$1`/g;
    # This is not necessary where they are surrounded by alphanumerics. Undo that special case.
    s/(?<=[[:alnum:]])`([*_^])`(?=[[:alnum:]])/$1/g;
    # Left bracket can be interpreted as link markup, so escape it unless already safe.
    #s/\[(?!\W)/[\e/g;
    # A bug in wiki rendering is causing problems with this markup at Sep 2009
    # See http://code.google.com/p/support/issues/detail?id=2437
    # I have no option but to wrap brackets in backticks to deal with this at the moment.
    s/([\[\]])/`$1`/g;
    # The following set are potentially markup-significant at the start of a line.
    # We prepend ESC if it *might* be the start of a line.
    s/^([=#-])/\e$1/;
    # The following items can be neutralised by interrupting them.
    s/~(?=~)/~\e/g;
    s/,(?=,)/,\e/g;
    s/\|(?=\|)/|\e/g;
    # Prefix WikiWords with exclamation and suffix them with double asterisk.
    # (The latter prevents following underscores from being absorbed into the WikiWord.)
    s/(@{[WIKIWORD_RE]})/\!$1**/g;
    # We don't want ESCs in our text! Replace them with the real interrupter: double underscore.
    s/\e/__/g;
    # "Less than" can introduce gadget markup, but underscore won't escape it.
    # Escape with "**" unless followed by a safe (non-word) character.
    s/<(?!\W)/<**/g;
    return ($_);
}

sub encode_pod {
    my ($self, $text) = @_;
    # Wraps POD text in wiki code markup as appropriate.
    my $code = '';
    # Produce backticks surrounded by triple-brace, and everything else surrounded by backticks.
    for (split(/(`+)/, $text)) {
	$code .= /`/ ? "{{{$_}}}" : "`$_`";
    }
    return ($code);
}
